home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
PBLIB1
/
UNITS
/
OBJSTRA.INC
< prev
next >
Wrap
Text File
|
1994-04-30
|
14KB
|
562 lines
{SECTION STR_object }
Procedure STR_object.init;
var nbytes: Word;
st : string[1];
begin
GetMem (strptr, 1);
st := '';
Move (st, strptr^, 1);
end;
procedure STR_object.dispose;
var nbytes: Word;
begin
IF strptr <> NIL then
begin
nbytes := Length(strptr^) + 1;
FreeMem (strptr, nbytes);
strptr := NIL;
end;
end;
Function STR_object.store (st: String): boolean;
var nbytes: Word;
begin
if strptr <> NIL then dispose;
nbytes := Length (st) + 1;
IF MaxAvail < nbytes then store := False
else begin
GetMem (strptr, nbytes);
Move (st, strptr^, nbytes);
store := True;
end;
end;
Function STR_object.fetch: String;
begin
IF strptr = NIL then
fetch := ''
ELSE fetch := strptr^;
end;
Procedure STR_object.dump;
begin
writeln('STR_object dump: ','{',seg(strptr):5,':',ofs(strptr):4,'}',
' ',length(strptr^),' ',strptr^);
end;
{SECTION STRA_object }
Procedure STRA_object.init(max : integer);
var l : longint;
i : integer;
begin
arrayptr := NIL;
arraymax := 0;
arrayused := 0;
arraysorted := true;
l := sizeof(STR_object) * max;
if memavail > l then
begin
getmem(arrayptr,l);
arraymax := max;
arrayused := 0;
for i := 1 to arraymax do arrayptr^[i].init;
modified := false;
end;
end;
procedure STRA_object.done;
var l : longint;
i : integer;
ok : boolean;
begin
l := sizeof(STR_object) * arraymax;
IF (arrayptr <> NIL) and (l > 0) then
begin
for i := 1 to arraymax do arrayptr^[i].dispose;
FreeMem (arrayptr,l);
arrayptr := NIL;
end;
arrayused := 0;
arraysorted := false;
end;
Procedure STRA_object.clear;
var i : integer;
ok : boolean;
begin
if arrayused < 1 then exit;
if arrayptr <> NIL then
begin
for i := 1 to arrayused do ok := arrayptr^[i].store('');
arrayused := 0;
modified := false;
end;
end;
Function STRA_object.Count : integer;
begin
Count := arrayused;
end;
Function STRA_object.sorted : boolean;
begin
sorted := arraysorted;
end;
Function STRA_object.ArrayMaxSize : integer;
begin
ArrayMaxSize := arraymax;
end;
Function STRA_object.append(st : string) : boolean;
var OK : boolean;
begin
OK := false;
if (arrayused < arraymax) and (MaxAvail > (length(st)+10)) then
begin
inc(arrayused);
OK := arrayptr^[arrayused].Store(st);
arraysorted := false;
modified := true;
end;
append := OK;
end;
Function STRA_object.appendpush(st : string) : boolean;
var OK : boolean;
begin
OK := true;
if (arrayused = arraymax) then ok := deletestr(1);
if OK then OK := STRA_object.storeN(arraymax,st);
appendpush := OK;
end;
Function STRA_object.storeN (n : integer; st : string): boolean;
var OK : boolean;
begin
OK := false;
if (n > 0) and (n <= arraymax) and (MaxAvail > (length(st)+10)) then
begin
if n > arrayused then arrayused := n;
OK := arrayptr^[n].Store(st);
modified := true;
arraysorted := false;
end;
storeN := OK;
end;
Function STRA_object.fetchN(n : integer) : string;
var s : string;
begin
s := '';
if (n > 0) and (n <= arrayused) then
begin
s := arrayptr^[n].fetch;
end;
fetchN := s;
end;
Function STRA_object.fetchString(n : integer) : string;
begin
fetchString := STRA_object.fetchN(n);
end;
Function STRA_object.fetchInteger(n : integer) : integer;
begin
fetchInteger := StrInt(STRA_object.fetchN(n));
end;
Function STRA_object.fetchLongInt(n : integer) : longint;
begin
fetchLongInt := StrLong(STRA_object.fetchN(n));
end;
Function STRA_object.fetchreal(n : integer) : real;
begin
fetchreal := StrReal(STRA_object.fetchN(n));
end;
Function STRA_object.fetchboolean(n : integer) : boolean;
var result : boolean;
s : string;
begin
result := false;
s := UpCaseStr(STRA_object.fetchN(n));
if s = 'YES' then result := true
else if s = 'TRUE' then result := true;
fetchboolean := result;
end;
Function STRA_object.LinearFind(st : string) : integer;
var n : integer;
found : boolean;
s : string;
begin
n := 0;
s := UpCaseStr(st);
if (arrayused > 0) then
begin
found := false;
while (n < arrayused) and not found do
begin
inc(n);
if s = arrayptr^[n].fetch then found := true;
end;
end;
if not found then n := 0;
linearfind := n;
end;
Function STRA_object.linearsearch(st : string; mode : byte) : integer;
var n : integer;
found : boolean;
s : string;
begin {mode 0 = exact; 1 = GE; 2 = LE assumes ascending sort}
n := 0;
s := UpCaseStr(st);
if (arrayused > 0) then
begin
found := false;
while (n < arrayused) and not found do
begin
inc(n);
if (s = arrayptr^[n].fetch) then found := true
else if (mode = 1) and (s < arrayptr^[n].fetch) then
found := true
else if (mode = 2) and (n < arrayused) then
begin
if (s > arrayptr^[n].fetch) and
(s < arrayptr^[n+1].fetch) then
found := true;
end;
end;
end;
if not found then n := 0;
linearsearch := n;
end;
Procedure STRA_object.dump;
var i : integer;
begin
if arrayused < 1 then exit;
for i := 1 to arrayused do
begin
writeln(i:4,' [',arrayptr^[i].fetch,'] ');
end;
writeln('');
end;
Procedure STRA_object.listpage(f,n,w : integer);
var i : integer;
begin
if (f > arrayused) or (arrayused < 1) then exit;
i := f;
if i < 1 then i := 1;
while (i < (f+n)) do
begin
writeln(leftstr(arrayptr^[i].fetch,w-1));
inc(i);
end;
end;
Procedure STRA_object.save(fname : string);
var i : integer;
OK : boolean;
TEXTF : TFILE_object;
begin
if arrayused < 1 then exit;
TEXTF.init(fname,true);
for i := 1 to arrayused do
begin
ok := TEXTF.append(STRA_object.fetchN(i));
end;
TEXTF.done;
end;
Procedure STRA_object.load(fname : string);
var s : string;
OK : boolean;
TEXTF : TFILE_object;
begin
TEXTF.init(fname,false);
ok := TEXTF.opened;
while ok do
begin
ok := TEXTF.fetchnext(s);
if ok then ok := STRA_object.append(s);
end;
modified := false;
TEXTF.done;
end;
Procedure STRA_object.loadsection(fname,sectiontag,sectionname : string);
var secttag,sectname : string[40];
sectlen : integer;
ok, found : boolean;
s : string;
TEXTF : TFILE_object;
begin
found := false;
secttag := UpcaseStr(sectiontag);
sectname := UpcaseStr(sectionname);
trim(sectname);
sectlen := length(sectname);
TEXTF.init(fname,false);
ok := TEXTF.opened;
while ok do
begin
ok := TEXTF.fetchnext(s);
if ok then
begin
if secttag = leftstr(UpCaseStr(s),length(secttag)) then
begin
if found then
begin
found := false;
ok := false;
end
else begin
delete(s,1,length(secttag));
RemoveLeading(s,' ');
if leftstr(UpCaseStr(s),sectlen) = sectname then
found := true;
end;
end
else if found then ok := STRA_object.append(s);
end;
end;
modified := false;
TEXTF.done;
end;
{$R-}
Procedure STRA_object.swap(i,j : integer);
var sptr : stringptr;
begin
sptr := arrayptr^[i].strptr;
arrayptr^[i].strptr := arrayptr^[j].strptr;
arrayptr^[j].strptr := sptr;
modified := true;
end;
procedure STRA_object.sort;
var Gap,I,J,N : integer;
s1,s2 : stringptr;
begin
if arraysorted then exit;
N := STRA_object.count;
Gap := N div 2;
while (Gap > 0) do
begin
I := Gap;
while (I < N) do
begin
J := I - Gap;
s1 := arrayptr^[J+Gap+1].strptr;
s2 := arrayptr^[J+1].strptr;
while (J >= 0) and (s1^ < s2^) do
begin
STRA_object.swap(J+1,J+Gap+1);
dec(J,Gap);
s1 := arrayptr^[J+Gap+1].strptr;
s2 := arrayptr^[J+1].strptr;
end;
inc(I);
end;
Gap:=Gap div 2;
end;
modified := true;
arraysorted := true;
end;
{$R+}
Function STRA_object.binsearchEQ(st : string) : integer; {exact match}
var i,n,p : integer;
s1 : string;
begin
p := 0;
n := arrayused;
while (n > 1) do
begin
n := (n + 1) div 2;
if st = arrayptr^[p+n].strptr^ then
begin
binsearchEQ := (p+n);
exit;
end
else if st > arrayptr^[p+n].strptr^ then p := p + n;
end;
binsearchEQ := 0;
end;
Function STRA_object.binsearchAPPROX(st : string) : integer;
{first generic match}
var i,n,p : integer;
s1 : string;
begin
p := 0;
n := arrayused;
while (n > 1) do
begin
n := (n + 1) div 2;
if st = arrayptr^[p+n].strptr^ then
begin
binsearchAPPROX := (p+n);
exit;
end
else if st > arrayptr^[p+n].strptr^ then p := p + n;
end;
if st = leftstr(arrayptr^[p+1].strptr^,length(st)) then
binsearchAPPROX := p+1
else binsearchAPPROX := 0;
end;
Function STRA_object.BinSearchLE(st : string) : integer; {returns LE}
var i,n,p : integer;
s1 : string;
begin
p := 0;
n := arrayused;
while (n > 1) do
begin
n := (n + 1) div 2;
if st = arrayptr^[p+n].strptr^ then
begin
BinSearchLE := (p+n);
exit;
end
else if st > arrayptr^[p+n].strptr^ then p := p + n;
end;
BinSearchLE := p;
end;
Function STRA_object.BinSearchGE(st : string) : integer; {returns LE}
var i,n,p : integer;
s1 : string;
begin
p := 0;
n := arrayused;
while (n > 1) do
begin
n := (n + 1) div 2;
if st = arrayptr^[p+n].strptr^ then
begin
BinSearchGE := (p+n);
exit;
end
else if st > arrayptr^[p+n].strptr^ then p := p + n;
end;
if p < arrayused then BinSearchGE := p+1
else BinSearchGE := 0;
end;
Function STRA_object.Find(st : string) : integer;
var n : integer;
begin
if arraysorted then n := STRA_object.binsearchEQ(st)
else n := STRA_object.linearfind(st);
Find := n;
end;
Function STRA_object.Search(st : string; mode : byte) : integer;
var n : integer;
begin
n := 0;
if arraysorted then
begin
case mode of
0 : n := STRA_object.binsearchEQ(st);
1 : n := STRA_object.binsearchGE(st);
2 : n := STRA_object.binsearchLE(st);
end;
end
else n := STRA_object.linearsearch(st,mode);
Search := n;
end;
Function STRA_object.insertstr(n : integer;st : string):boolean;
{ append the item to the array, then bubble down to position }
var ok : boolean;
i : integer;
begin
ok := STRA_object.append(st);
if ok then
begin
modified := true;
if (n+1) < count then
begin
for i := count-1 downto n+1 do swap(i+1,i);
end;
end;
insertstr := ok;
end;
Function STRA_object.deletestr(n : integer):boolean;
{ for now, just bubble the item to the end, replace with
null string and decrement the count - this leaves some
heap garbage which I will ignore for now }
var ok : boolean;
i : integer;
begin
if n <= count then
begin
if (n+1) < count then
begin
for i := n to count-1 do swap(i+1,i);
end;
ok := STRA_object.storeN(count,'');
dec(arrayused);
modified := true;
end;
deletestr := ok;
end;